perm filename PARSE.SAI[PNT,HE]7 blob
sn#466134 filedate 1979-08-13 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00014 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 ENTRY
C00004 00003 ! expr list => expr array
C00005 00004 ! begin,cobegin,end,coend,if,for,while,do,case,on
C00010 00005 ! decl,simpledecl,arraydecl,procdecl,return
C00025 00006 ! setbase,wrist,gather,readwrist,setstiff
C00030 00007 ! vt05,print,prompt,abort
C00032 00008 ! affix,unfix
C00034 00009 ! fclproc,closeproc
C00038 00010 ! coordproc
C00040 00011 ! define reserved token codes
C00048 00012 ! tables to set up reserved words
C00051 00013 ! decoding a token to give its various parameters
C00053 00014 ! procedure parse itself
C00056 ENDMK
C⊗;
ENTRY;
BEGIN "PARSE"
DEFINE $$PRGID=TRUE; DEFINE $PARSE=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
RCLASS EXPR$LST(RPTR(EXPR$) PTR; RPTR(EXPR$LST) NEXT);
RCLASS EXPR$ARR(RPTR(EXPR$) ARRAY PTR);
DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];
! expr list => expr array ;
RPTR(EXPR$ARR) PROCEDURE ARRIFY(RPTR(EXPR$LST)PTR);
BEGIN
INTEGER I,NRECS; RPTR(EXPR$LST)PPTR;
NRECS←0; PPTR←PTR;
WHILE PPTR DO BEGIN NRECS←NRECS+1; PPTR←EXPR$LST:NEXT[PPTR]; END;
BEGIN
RPTR(EXPR$)ARRAY P[1:NRECS];
RPTR(EXPR$ARR) E;
PPTR←PTR;
FOR I←1 STEP 1 UNTIL NRECS DO
BEGIN
P[I]←EXPR$LST:PTR[PPTR];
PPTR←EXPR$LST:NEXT[PPTR];
END;
E←NEW_RECORD(EXPR$ARR);
MEMORY[LOCATION(EXPR$ARR:PTR[E])]↔MEMORY[LOCATION(P)];
RETURN(E);
END;
END;
! begin,cobegin,end,coend,if,for,while,do,case,on;
RECURSIVE PROCEDURE BEGINPROC;
BEGIN
RPTR(EXPR$)PBEGIN,PBEGIN2;
RPTR(BLOCKREC)B;
INTEGER TMPOFF;
$COMPILE←$COMPILE+1;
$LEVEL←$LEVEL+1;
TMPOFF←$TMPOFF;
B←NEW_RECORD(BLOCKREC);
BLOCKREC:NEXT[B]←CURBLOCK;
CURBLOCK←B;
PBEGIN←NULL!RECORD;
DO BEGIN
PBEGIN2←PARSE;
PBEGIN←$APPEND(PBEGIN,PBEGIN2);
GTOKEN;
IF TOKEN≠";" AND NOT EQU(TOKEN,"END")
THEN ERROR("Need semicolon to separate statements");
END UNTIL EQU(TOKEN,"END");
$$PCODE←$APPEND(PBEGIN,$KVARPCODE(BLOCKREC:#ARGS[CURBLOCK]));
CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
$TMPOFF←TMPOFF;
$LEVEL←$LEVEL-1;
$COMPILE←$COMPILE-1;
END;
RECURSIVE PROCEDURE COBEGINPROC;
BEGIN
RPTR(EXPR$LST)E$HEAD,E$CUR;
INTEGER TMPOFF;
$COMPILE←$COMPILE+1;
$LEVEL←$LEVEL+1;
TMPOFF←$TMPOFF;
E$HEAD←E$CUR←NEW_RECORD(EXPR$LST);
DO BEGIN
RPTR(BLOCKREC)B;
B←NEW_RECORD(BLOCKREC);
BLOCKREC:NEXT[B]←CURBLOCK;
CURBLOCK←B;
$TMPOFF←'1000 - 1;
EXPR$LST:NEXT[E$CUR]←NEW_RECORD(EXPR$LST);
E$CUR←EXPR$LST:NEXT[E$CUR];
EXPR$LST:PTR[E$CUR]←PARSE;
CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
GTOKEN;
IF TOKEN≠";" AND NOT EQU(TOKEN,"COEND")
THEN ERROR("Need semicolon to separate statements");
END UNTIL EQU(TOKEN,"COEND");
$$PCODE←$COBEGPCODE(EXPR$ARR:PTR[ARRIFY(EXPR$LST:NEXT[E$HEAD])]);
$TMPOFF←TMPOFF;
$LEVEL←$LEVEL-1;
$COMPILE←$COMPILE-1;
END;
PROCEDURE ENDPROC(STRING E("END"));
BEGIN
IF $COMPILE=0 THEN ERROR("Encountered "&E&" as a statement.... strange");
STOKEN←TRUE;
$$PCODE←NULL_RECORD;
END;
RECURSIVE PROCEDURE IFPROC;
BEGIN
RPTR(EXPR$)COND,A,B;
$COMPILE←$COMPILE+1;
COND←$$GTANYEXP("condition part of IF statement",#SC);
WORD_READ("THEN");
A←PARSE;
GTOKEN;
B←NULL_RECORD;
IF EQU(TOKEN,"ELSE") THEN B←PARSE
ELSE IF TOKEN=";" OR EQU (TOKEN, "END") THEN STOKEN←TRUE
ELSE ERROR("Only ELSE or ; allowed after then part");
$COMPILE←$COMPILE-1;
$$PCODE←$IFPCODE(COND,A,B)
END;
RECURSIVE PROCEDURE FORPROC;
BEGIN
RPTR(SYMBOL)S;
RPTR(EXPR$)LB,UB,STE,STATE;
$COMPILE←$COMPILE+1;
GTOKEN;
IF TOKENINDEX≠#SC THEN ERROR("Need scalar for FOR statement");
S←TOKENPTR;
WORD_READ("←");
LB←$$GTANYEXP("FOR statement",#SC);
WORD_READ("STEP");
STE←$$GTANYEXP("FOR statement",#SC);
WORD_READ("UNTIL");
UB←$$GTANYEXP("FOR statement",#SC);
WORD_READ("DO");
STATE←PARSE;
$$PCODE←$FORPCODE(S,LB,STE,UB,STATE);
$COMPILE←$COMPILE-1;
END;
RECURSIVE PROCEDURE WHILEPROC;
BEGIN
RPTR(EXPR$)COND,S;
$COMPILE←$COMPILE+1;
COND←$$GTANYEXP("condition part of WHILE statement",#SC);
WORD_READ("DO");
S←PARSE;
$COMPILE←$COMPILE-1;
$$PCODE←$WHILEPCODE(COND,S);
END;
RECURSIVE PROCEDURE DOPROC;
BEGIN
RPTR(EXPR$)S,COND;
$COMPILE←$COMPILE+1;
S←PARSE;
WORD_READ("UNTIL");
COND←$$GTANYEXP("UNTIL part of DO statement",#SC);
$$PCODE←$DOPCODE(S,COND);
$COMPILE←$COMPILE-1;
END;
! decl,simpledecl,arraydecl,procdecl,return;
PROCEDURE PROCDECLPROC(INTEGER OBTYPE(#PR));
BEGIN "procedure declaration"
STRING ATOKEN;INTEGER NARGS,SYMACCS;
INTEGER ARRAY ACCESS,TYPE,ARRDIM,ARGOFF[1:10];
STRING ARRAY ARGNAME[1:10];
RPTR(SYMBOL) ARRAY SYMARR[1:10];
RPTR(PROC)PSYM; RPTR(EXPR$)PBODY; RPTR(SYMBOL)SYM; RANY DATPTR;
IF CURPROC THEN ERROR("Cant have procedure inside procedure");
IF CURBLOCK THEN ERROR("Cant have procedure inside block");
$COMPILE←$COMPILE+1; $LEVEL←1;
GTOKEN;
IF #TOKEN≠UNDECLARED_TYPE THEN
ERROR("Need undeclared identifier for procedure declaration");
ATOKEN←TOKEN;
NARGS←0; $TMPOFF←'1000-1; ! starting value ;
GTOKEN;
IF TOKEN="(" THEN
DO BEGIN "procedure with parameters"
INTEGER CACCESS,CTYPE; BOOLEAN ARRDECL;
GTOKEN;
ARRDECL←FALSE;
CACCESS←#REFTYP; SYMACCS←#SIMPLE;
IF EQU(TOKEN,"VALUE") THEN CACCESS←0
ELSE IF EQU(TOKEN,"REFERENCE") THEN CACCESS←#REFTYP
ELSE STOKEN←TRUE;
GTOKEN;
FOR CTYPE←#SC STEP 1 UNTIL #FR DO
IF EQU(TOKEN,$DTYPE[CTYPE]) THEN DONE;
IF NOT(#SC≤CTYPE≤#FR) THEN ERROR("Need basic data type declaration here");
GTOKEN;
DATPTR←NULL_RECORD;
IF EQU(TOKEN,"ARRAY") THEN
BEGIN CACCESS←#REFTYP+#ARRTYP;
ARRDECL←TRUE; SYMACCS←#ARRAY;
END ELSE STOKEN←TRUE;
DO BEGIN "get list of parameters"
INTEGER I;
IF NARGS>10 THEN ERROR("Cant take more than 10 parameters");
GTOKEN;
! now check if we have used this before ;
IF NOT(#TOKEN≠UNDECLARED_TYPE OR #TOKEN≠ID_TYPE) THEN
ERROR("Need undeclared or id token here");
FOR I←1 STEP 1 UNTIL NARGS DO
IF EQU(TOKEN,ARGNAME[I]) THEN DONE;
IF EQU(TOKEN,ATOKEN) THEN I←NARGS;
IF I≠NARGS+1 THEN ERROR(TOKEN&" has already been used in this procedure");
NARGS←NARGS+1;
TYPE[NARGS]←CTYPE; ACCESS[NARGS]←CACCESS;
ARGNAME[NARGS]←TOKEN;
ARGOFF[NARGS]←($TMPOFF←$TMPOFF+1);
IF ARRDECL THEN
BEGIN "array in argument list"
RPTR(EXPR$)E;
INTEGER I; I←0;
WORD_READ("[");
DO BEGIN "no of arguments"
E←$$GTANYEXP("for field of array declaration",#SC);
WORD_READ(":");
E←$$GTANYEXP("for dimension field of array dec",#SC);
I←I+1;
GTOKEN;
IF TOKEN≠"," AND TOKEN≠"]" THEN ERROR("Need , or ] here");
END "no of arguments" UNTIL TOKEN="]";
IF I>5 THEN ERROR("Array dimension must be less than 5");
ARRAYREC:#DIM[DATPTR←NEW_RECORD(ARRAYREC)]←ARRDIM[NARGS]←I;
END "array in argument list";
SYMBOL:OFFSET[SYMARR[NARGS]←MK_SYM(ARGNAME[NARGS],
TYPE[NARGS],DATPTR,SYMACCS)] ← $TMPOFF;
GTOKEN;
END "get list of parameters" UNTIL TOKEN≠",";
IF TOKEN≠")" AND TOKEN≠";" THEN ERROR("Need ; or , or ) here");
END "procedure with parameters" UNTIL TOKEN=")"
ELSE STOKEN←TRUE;
WORD_READ(";");
PSYM←MK_PR(NARGS,ARGNAME,TYPE,ACCESS,ARRDIM);
SYM←CURPROC←MK_SYM(ATOKEN,OBTYPE,PSYM,#PROCEDURE);
SYMBOL:OFFSET[CURPROC]←$SYMOFF;
CURBLOCK←BLOCKIFY(NARGS,SYMARR);
BLOCKREC:LEVEL[CURBLOCK]←$LEVEL;
PBODY←PARSE;
$$PCODE←$PRCDCLPCODE(SYM,PBODY);
ENSYM$(SYM);
$SYMOFF←$SYMOFF+1;
$COMPILE←$COMPILE-1;
END;
IFC NOT #nofunct THENC
PROCEDURE FUNCTPROC(INTEGER OBTYPE(0);STRING OBSTRING(NULL));
BEGIN
STRING SSSS;
PROCEDURE GGTOKEN;
BEGIN GTOKEN; SSSS←SSSS&" "&TOKEN; END;
SSSS←OBSTRING&" "&TOKEN;
BEGIN "declar function"
INTEGER NARGS; RPTR(SYMBOL) S;integer tt,FT; STRING FBODY;
RPTR(EXPR) SYMBOLSUSED;
RCLASS TEMP(RPTR(EXPR) PTR; INTEGER TYPE;
STRING NAME;RPTR(TEMP)NEXT);
RPTR (TEMP) T,T1;RPTR(TREE)TRE;RPTR(FUNCTION) F; STRING FNAME;
NARGS←0; GGTOKEN;
IF #TOKEN≠UNDECLARED_TYPE
THEN ERROR($SYNMSG[35],$SYNMSG[25])
ELSE BEGIN "declar function"
FNAME←TOKEN;
GGTOKEN; T←NEW_RECORD(TEMP);
IF TOKEN="(" THEN
BEGIN "parametic procedure "
DO BEGIN "declar param type"
GGTOKEN;
IF EQU(TOKEN,"SCALAR") THEN FT←#SC
ELSE IF EQU(TOKEN,"VECTOR") THEN FT←#VT
ELSE IF EQU(TOKEN,"ROT") THEN FT←#RT
ELSE IF EQU(TOKEN,"TRANS") THEN FT←#TR
ELSE IF EQU(TOKEN,"FRAME") THEN FT←#FR
ELSE ERROR("need declaration class");
DO BEGIN "declar param"
GGTOKEN;
IF #TOKEN≠UNDECLARED_TYPE
THEN ERROR("function parameter should be undeclared variable");
T1←NEW_RECORD(TEMP);
TEMP:TYPE[T1]←FT;TEMP:NAME[T1]←TOKEN;
TEMP:NEXT[T1]←T;T←T1;NARGS←NARGS+1;GGTOKEN;
END "declar param"
UNTIL TOKEN≠",";
END "declar param type"
UNTIL TOKEN≠";" ;
IF TOKEN ≠ ")" THEN ERROR("need close paren or semicolon here");
END "parametic procedure "
ELSE BEGIN STOKEN←TRUE; SSSS←SSSS[1 TO ∞ - 1]; END;
F←MK_FN(NARGS); FUNCTION:TYPE[F]←OBTYPE; FUNCTION:HEAD[F]←SSSS;
FOR TT←NARGS STEP -1 UNTIL 0 DO
BEGIN
EXPR:TYPE[FUNCTION:PTR[F][TT]←NEW_RECORD(EXPR)]←
FUNCTION:ARGTYPE[F][TT]←TEMP:TYPE[T];
FUNCTION:ARGNAME[F][TT]←TEMP:NAME[T];
T←TEMP:NEXT[T];
END;
GGTOKEN;
IF TOKEN≠"=" THEN ERROR("need = here");
TRE←FNEXPR(F,FBODY,SYMBOLSUSED);
BEGIN RPTR(EXPR) T;
T←NEW_RECORD(EXPR);
EXPR:PTR[T]←TREE:DATA[TRE];
ifc false thenc buggy right now IF OBTYPE=0 THEN
BEGIN EXPR:TYPE[T]←TREE:DTYPE[TRE];
obtype←expr:type[expr:ptr[t]];
function:type[f]←obtype mod #dtype;
function:head[f]←$dtype[obtype mod #dtype]&function:head[f];
END
ELSE
IF (EXPR:TYPE[T]←TREE:DTYPE[TRE])mod #dtype≠OBTYPE
THEN ERROR("function type not same as declared");
elsec expr:type[t]←tree:dtype[tre];endc FUNCTION:EXPR[F]←T;
END;
FUNCTION:BODY[F]←FBODY;
S←INSERT(FNAME,#FN); SYMBOL:OBJECT[S]←F;
UNRAVEL_SYMBOLS_USED(SYMBOLSUSED,S);
IFC #DISPL THENC $FNLST←NULL; UPDATE; ENDC
END "declar function";
END "declar function";
END;
ENDC
! parses the declaration instructions
SCALAR <id>,<id>,...
VECTOR <id>,<id>,...
FRAME <id>,<id>,...
ROT <id>,<id>,...;
PROCEDURE SIMPLEDECL(INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)ARRAY SPTR[1:10];
INTEGER I,J; J←0;
DO BEGIN "A"
IF J=10 THEN ERROR("Can only declare 10 variables in a declaration");
GTOKEN;
IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
THEN ERROR($SYNMSG[35],$SYNMSG[25])
ELSE BEGIN "check current list"
INTEGER K;
FOR K←1 STEP 1 UNTIL J DO
IF EQU(SYMBOL:PNAME[SPTR[K]],TOKEN) THEN DONE;
IF K=J+1 THEN SPTR[J←J+1]←NNWR(TOKEN,OBTYPE)
ELSE ERROR(TOKEN&" is not undeclared");
END "check current list";
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL
THEN ERROR($SYNMSG[0]&$SYNMSG[25]&" OR ",$SYNMSG[1]&$SYNMSG[25]);
END "A" UNTIL FINAL;
IF CURBLOCK
THEN FOR I←1 STEP 1 UNTIL J DO
BEGIN INSERTSYMTREE(SPTR[I],CURBLOCK);
SYMBOL:OFFSET[SPTR[I]]←($TMPOFF←$TMPOFF+1);
$$PCODE←$SMPDCLPCODE(OBTYPE,J);
STOKEN←TRUE;
END
ELSE FOR I←1 STEP 1 UNTIL J DO ENSYM$(SPTR[I]);
$DISPLAYLIST[OBTYPE]←NULL;
END;
! to handle array declarations;
PROCEDURE ARRAYDECLPROC(INTEGER OBTYPE);
BEGIN "array declaration"
RPTR(EXPR$)PARRAY;
INTEGER NARRAY;
RPTR(EXPR$) ARRAY PLIST[1:10];
RPTR(SYMBOL) ARRAY SYMLST[1:10];
NARRAY←0;
DO BEGIN "get another one"
STRING ATOKEN; INTEGER ADIM; RPTR(EXPR$)ARRAY BOUNDS[1:10];
RPTR(ARRAYREC) DIMREC;
IF NARRAY≥10 THEN ERROR("Can't have more than 10 variables in a declaration");
ADIM←0; GTOKEN;
IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
THEN ERROR("Need undeclared identifier for array declaration");
ATOKEN←TOKEN; WORD_READ("[");
DO BEGIN
IF ADIM=5 THEN ERROR("Cant have more than 5 fields in array declaration");
BOUNDS[ADIM*2+1]←$$GTANYEXP("for array dimension",#SC);
WORD_READ(":"); BOUNDS[ADIM*2+2]←$$GTANYEXP("for array dimension",#SC);
GTOKEN;
IF TOKEN≠"," AND TOKEN≠"]"THEN ERROR("Need , here"); ADIM←ADIM+1;
END UNTIL TOKEN="]";
PLIST[NARRAY←NARRAY+1]←$ARRDCLPCODE(BOUNDS,OBTYPE,ADIM,
NARRAY +(IF CURBLOCK THEN $TMPOFF ELSE $SYMOFF-1));
ARRAYREC:#DIM[DIMREC←NEW_RECORD(ARRAYREC)]←ADIM;
SYMLST[NARRAY]←MK_SYM(ATOKEN,OBTYPE,DIMREC,#ARRAY);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma or semicolon here");
END UNTIL FINAL;
IF TOKEN=";" THEN STOKEN←TRUE;
PARRAY←NULL_RECORD;
IF CURBLOCK THEN
BEGIN INTEGER I; RPTR(SYMBOL)S;
FOR I←1 STEP 1 UNTIL NARRAY DO
BEGIN
INSERTSYMTREE(S←SYMLST[I],CURBLOCK);
SYMBOL:OFFSET[S]←($TMPOFF←$TMPOFF+1);
PARRAY←$APPEND(PARRAY,PLIST[I]);
END;
END
ELSE BEGIN
INTEGER I; RPTR(SYMBOL)TEMP;
FOR I← 1 STEP 1 UNTIL NARRAY DO
BEGIN
ENSYM$(TEMP←SYMLST[I]);
SYMBOL:OFFSET[TEMP]←$SYMOFF;$SYMOFF←$SYMOFF+1;
PARRAY←$APPEND(PARRAY,PLIST[I]);
END;
END;
$$PCODE←PARRAY;
END "array declaration";
PROCEDURE DECLPROC (INTEGER OBTYPE);
BEGIN
GTOKEN;
IF EQU(TOKEN,"PROCEDURE")
THEN PROCDECLPROC(OBTYPE)
ELSE IF EQU(TOKEN,"ARRAY")
THEN ARRAYDECLPROC(OBTYPE)
ELSE BEGIN
STOKEN←TRUE;
SIMPLEDECL(OBTYPE);
END;
END;
PROCEDURE RETURNPROC;
BEGIN RPTR(EXPR$)EXP;
IF $COMPILE=0 THEN ERROR("RETURN can only be inside a block");
EXP←NULL_RECORD; GTOKEN;
IF TOKEN="(" THEN
BEGIN EXP←$$GTEXPR; GTOKEN;
IF TOKEN≠")" THEN ERROR("Need right paren here");
END
ELSE STOKEN←TRUE;
$$PCODE←$RTNPCODE(EXP);
END;
! setbase,wrist,gather,readwrist,setstiff;
PROCEDURE SETBASEPROC;
$$PCODE←$SETBASEPCODE;
PROCEDURE WRISTPROC;
BEGIN RPTR(SYMBOL) S;
WORD_READ("("); GTOKEN;
IF TOKENPTR=NULL_RECORD OR
SYMBOL:TYPE[TOKENPTR]≠#SC OR
SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
OR ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]≠1
THEN ERROR("Need one dimensioned scalar array in WRIST");
S←TOKENPTR; WORD_READ(")");
$$PCODE←$WRISTPCODE(S);
END;
IFC #GATHER THENC
PRESET_WITH "FX","FY","FZ","MX","MY","MZ","T1","T2","T3","T4","T5","T6","TBL";
STRING ARRAY GATHCODES[0:12];
PROCEDURE GATHERPROC;
BEGIN INTEGER STATUS,I; INTEGER S1;
WORD_READ("("); STATUS←0;
DO BEGIN
GTOKEN;
FOR I←0 STEP 1 UNTIL 12 DO IF EQU(TOKEN,GATHCODES[I]) THEN DONE;
IF I>12 THEN ERROR("Unrecognized code found: ",TOKEN);
STATUS←STATUS LOR ('1 LSH I);
GTOKEN;
END UNTIL TOKEN≠",";
IF TOKEN≠")" THEN ERROR("Need right paren here");
$$PCODE←$GATHERPCODE(STATUS);
END;
ENDC
IFC #WRIST THENC
PROCEDURE READWRISTPROC;
BEGIN STRING COMMAND,FNAME; INTEGER VAL;
IF $COMPILE≠0 THEN PRINT(CRLF,"WARNING: you should not put READWRIST
inside a block...",crlf,"We make no promises",CRLF);
VAL←0;FNAME←NULL;
WORD_READ("(");
GTOKEN;
COMMAND←TOKEN;
IF EQU("CALIB",COMMAND) OR EQU("RENAMEFILE",COMMAND) THEN
BEGIN
GTOKEN;
IF TOKEN≠"," THEN ERROR("Need comma after CALIB or RENAMEFILE");
IF EQU(COMMAND,"CALIB") THEN
BEGIN
GTOKEN;
VAL←INTSCAN(TOKEN,$BRCHR);
IF VAL<1 OR VAL>6
THEN ERROR("Calib code must be between 1 and 6");
END
ELSE FNAME←NAMEFILE;
END
ELSE IF EQU("SAVERAWDATA",COMMAND) THEN
BEGIN
STRING S; S←NULL;
GTOKEN;
IF TOKEN≠"," THEN ERROR("Need comma after SAVERAWDATA");
GTOKEN;
IF TOKEN≠"""" THEN ERROR("need double quote here");
GTOKEN;
WHILE TOKEN≠"""" DO BEGIN S←S&TOKEN&" "; GTOKEN; END;
FNAME←S;
END;
WORD_READ(")");
GTOKEN(FALSE);
IF NOT FINAL THEN ERROR("This is an incomplete instruction")
ELSE IF EQU(COMMAND,"READ") THEN
$$PCODE←$RFORCEPCODE
ELSE IF VAL←RWRIST(COMMAND,VAL,FNAME) THEN
ERROR("ERROR in reading wrist",$WRMSG[VAL]);
END;
ENDC
PROCEDURE SETSTIFFPROC;
BEGIN
RPTR(EXPR$) ARRAY E[1:8];
INTEGER NARGS;
WORD_READ("("); NARGS←0;
DO BEGIN
E[NARGS←NARGS+1]←$$GTANYEXP("argument in SETSTIFF",#SC);
GTOKEN;
END UNTIL TOKEN≠"," OR NARGS=6;
IF TOKEN≠"," THEN ERROR("Need comma here")
ELSE E[7]←$$GTANYEXP("argument in SETSTIFF",#FR);
GTOKEN;
IF TOKEN≠")" THEN ERROR("Need right paren after 7th argument");
E[8]←$SETSTFPCODE;
$$PCODE←$AAPPEND(E);
END;
PROCEDURE DDTPROC;
$$PCODE←$DDTPCODE;
! vt05,print,prompt,abort;
PROCEDURE VT05PROC(INTEGER STATE);
$$PCODE←$VT05PCODE(STATE);
RPTR(EXPR$)PROCEDURE PRINTCODE;
BEGIN
RPTR(EXPR$)P; P←NULL_RECORD;
WORD_READ("(");
DO BEGIN
GTOKEN;
IF TOKEN=dquote
THEN BEGIN "string found"
READTILL(dquote);
P←$APPEND(P,$PRNPCODE(TOKEN))
END
ELSE BEGIN "expression found"
STOKEN←TRUE;
P←$APPEND(P,$PRVPCODE($$GTEXPR));
END;
GTOKEN;
END UNTIL TOKEN≠",";
IF TOKEN≠")" THEN ERROR("Need ) for end of PRINT list");
RETURN(P);
END;
PROCEDURE PRINTPROC;
$$PCODE←PRINTCODE;
PROCEDURE ABORTPROC;
$$PCODE←$APPEND(PRINTCODE,$ABORTPCODE);
PROCEDURE PROMPTPROC;
$$PCODE←$APPEND(PRINTCODE,$PROMPTPCODE);
! affix,unfix;
PROCEDURE UNFIXPROC;
BEGIN
RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
EX1←$$GTIDREF(#FR,FRM1,"first frame of unfix");
WORD_READ("FROM"); ! change this to handle just UNFIX FRAME1;
EX2←$$GTIDREF(#FR,FRM2,"second frame of UNFIX");
$$PCODE←$UFXPCODE(EX1,EX2);
END;
! parses the instruction
AFFIX <frame_id> TO <frame_id> {AT TRANS(<rot>,<vector>)};
PROCEDURE AFFIXPROC;
BEGIN
INTEGER AFFTYPE;RPTR(EXPR$)TEMP;
RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
EX1←$$GTIDREF(#FR,FRM1,"first frame of affix");
WORD_READ("TO");
EX2←$$GTIDREF(#FR,FRM2,"second frame of affix");
GTOKEN(FALSE);
TEMP←NULL_RECORD;
IF EQU(TOKEN,"AT")
THEN BEGIN "AT"
TEMP←$$GTANYEXP("offset part of AFFIX statement",#FR);
GTOKEN(FALSE);
END "AT";
IF FINAL
THEN AFFTYPE←#RGDLK
ELSE BEGIN "D"
IF TOKEN="+" OR EQU(TOKEN,"NONRIGIDLY") THEN AFFTYPE← #NRGLK
ELSE IF TOKEN="*" OR EQU(TOKEN,"RIGIDLY") THEN AFFTYPE← #RGDLK
ELSE ERROR($SYNMSG[30],NULL);
SEMICOL_READ;
END "D";
$$PCODE←$AFXPCODE(EX1,EX2,AFFTYPE,TEMP);
END ;
! fclproc,closeproc;
! closes any open file, after a confirmation;
PROCEDURE FCLPROC;
BEGIN
STRING ANSWER;
$HELP←36;
SEMICOL_READ;
PRINT("Any open file will be closed. Are you sure?");
ANSWER←INCHRW;
PRINT(CRLF);
ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN BEGIN
IFC #OUTPT THENC FCLOSE;ENDC
END
ELSE ABORT1($SEMSG[13]);
IFC #OUTPT THENC TTYSAVE; ENDC ! file status modified;
$OULST←NULL;
END;
! parses the instructions
CLOSE {<filename>} (default=last used file)
CLOSE <hand> TO|BY <scalar> (BHAND as default);
PROCEDURE CLOSEPROC;
BEGIN
STRING FL,ANSWER;
$HELP←30;
GTOKEN(FALSE);
IF FINAL THEN
IFC #OUTPT THENC AL_CLOSE($ALFL) ELSEC ABORT1(#VERSION) ENDC
ELSE
BEGIN "MORE"
IF EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND")
OR EQU(TOKEN,"TO") OR EQU(TOKEN,"BY")
THEN BEGIN "HAND"
STRING WHAT; INTEGER IND;
WHAT←TOKEN;
GTOKEN(FALSE);
IF FINAL
THEN
IFC #OUTPT THENC
BEGIN "FILECHECK"
IND←ISFILE(WHAT);
IF IND THEN
BEGIN
PRINT("do you want to close the file?");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN AL_CLOSE(WHAT)
ELSE ABORT1($SEMSG[13]);
END
ELSE
IF EQU(WHAT,"BHAND") OR EQU(WHAT,"YHAND") THEN
BEGIN
STRING HOW;
HOW←IDF_READ;
IF EQU(HOW,"BY") OR EQU(HOW,"TO")
THEN OPENING("CLOSE",WHAT,HOW)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END
ELSE OPENING("CLOSE","BHAND",WHAT);
END "FILECHECK"
ELSEC PRINT(#VERSION) ENDC
ELSE
IF EQU(WHAT,"TO") OR EQU(WHAT,"BY") THEN
BEGIN
STOKEN←TRUE;
OPENING("CLOSE","BHAND",WHAT); ! default=BHAND;
END
ELSE
IF EQU(TOKEN,"TO") OR EQU(TOKEN,"BY") THEN
OPENING("CLOSE",WHAT,TOKEN)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END "HAND"
ELSE
BEGIN
STOKEN←TRUE;
FL←NAMEFILE;
SEMICOL_READ;
IFC #OUTPT THENC AL_CLOSE(FL);ENDC
END;
END "MORE";
END;
! coordproc;
PROCEDURE COORDPROC (INTEGER ELEMENT,TYPE);
BEGIN
RPTR(EXPR$) EX1,EX2; RPTR(SYMBOL) S;INTEGER TYPEF;
S←NULL_RECORD; ! element=0,1,2,3 depending on instr;
WORD_READ("(");
EX1←IDREF(S); ! read the argument&look for predeclared;
IF PRDECL(S) THEN
ERROR("You cannot change the value of"&SYMBOL:PNAME[S] );
! check for correct type of argument;
CASE (TYPEF←EXPR$:TYPE[EX1]) OF
BEGIN
[#SC][#RT] ERROR("unexpected type");
[#VT] IF ELEMENT=0 THEN ERROR("unexpected type");
ELSE
END;
WORD_READ(")");
WORD_READ("←");
! reads the expression according to the type;
CASE TYPE OF
BEGIN
[#SC] EX2←$$GTANYEXP("X-Y-Z coord",#SC);
[#VT] EX2←$$GTANYEXP("POS",#VT);
[#RT] EX2←$$GTANYEXP("ORIENT",#RT);
ELSE ERROR("COORDPROC: unexpected type")
END;
$DISPLAYLIST[TYPEF]←NULL;
$$PCODE←$COORDPCODE(EX1,EX2,ELEMENT,TYPE);
END;
! define reserved token codes ;
! format is as follows:
ZZ(symbol, opcode number, precedence level) for operators
XX(flag, statement reserved word, parsing procedure to call)
where flag indicates whether this statement
is available in the current version
XXZZ(flag, symbol, parsing procedure, opcode number, precedence level)
for symbols which are both operators and
first words of statements ;
define tokencodes "[][]" =[
ZZ("↓", DOWNARROW_X, PF_XX)
ZZ("∧", and_X, BFACT_XX)
ZZ("¬", not_X, PF_XX)
ZZ("⊗", xor_X, BEFACT_XX)
ZZ("→", frontarrow_X, FACTOR_XX)
ZZ("≠", sne_X, BTERM_XX)
ZZ("≤", sle_X, BTERM_XX)
ZZ("≥", sge_X, BTERM_XX)
ZZ("≡", eqv_X, EXP_XX)
ZZ("∨", or_X, BEFACT_XX)
ZZ("$", DOLLAR_X, PF_XX)
ZZ("α", ALPHA_X, PF_XX)
ZZ(["("], LPAREN_X, PF_XX)
ZZ("*", times_X, TERM_XX)
ZZ("+", Plus_X, AEXP_XX)
ZZ("-", minus_X, AEXP_XX)
ZZ(".", vdot_X, TERM_XX)
ZZ("/", sdiv_X, TERM_XX)
ZZ("<", slt_X, BTERM_XX)
ZZ("=", seq_X, BTERM_XX)
ZZ(">", sgt_X, BTERM_XX)
XX(TRUE, ABORT, ABORTPROC)
ZZ("ACOS", acos_X, PF_XX)
XX(TRUE, AFFIX, AFFIXPROC)
XX(TRUE, ALL, NOTAVAILCALL)
ZZ("AND", aand_X, BFACT_XX)
XX(TRUE, ARRAY, NOTAVAILCALL)
ZZ("ASIN", asin_X, PF_XX)
ZZ("ATAN2", atan2_X, PF_XX)
ZZ("AXIS", axis_X, PF_XX)
XX(TRUE, BAIL, BAILCALL)
XX(TRUE, BEGIN, BEGINPROC)
XX(#MOVE, BY, DEFLT("BY"))
XX(TRUE, CASE, CASEPROC)
XX(#MOVE, CENTER, CENTERPROC)
XX(TRUE, CLOSE, CLOSEPROC)
XX(TRUE, CLOSE_FILES, FCLPROC)
XX(TRUE, COBEGIN, COBEGINPROC)
XX(TRUE, COEND, ENDPROC("COEND"))
XX(TRUE, COMMENT, [READTO(";")])
ZZ("CONSTRUCT", construct_X, PF_XX)
XX(TRUE, COPY, COPYCALL)
ZZ("COS", cos_X, PF_XX)
XX(TRUE, DDT, DDTPROC)
XX(TRUE, DEFINE, DEFINECALL)
XX(TRUE, DELETE, DELETECALL)
XX(#DISPL, DISPLAY, DISPLAYCALL)
ZZ("DIV", div_X, TERM_XX)
XX(TRUE, DO, DOPROC)
XX(#MOVE, DRIVE, DRIVEPROC)
XX(TRUE, ECHOOFF, [FILEPRINT←FALSE])
XX(TRUE, ECHOON, [FILEPRINT←TRUE])
XX(TRUE, EDIT, EDITCALL("EDIT"))
XX(TRUE, EEDIT, EEDITCALL)
XX(TRUE, END, ENDPROC)
ZZ("EQV", eeqv_X, EXP_XX)
ZZ("EVAL", EVAL_X, PF_XX)
XX(TRUE, EXIT, EXITCALL)
ZZ("EXP", exp_X, PF_XX)
XX(FALSE, FCONSTRUCT, FCONSTRUCTPROC)
XX(TRUE, FOR, FORPROC)
XXZZ(TRUE, FRAME, DECLPROC(#FR), FRAME_X, PF_XX)
XX(not #nofunct, FUNCTION, FUNCTPROC)
XX(#GATHER, GATHER, GATHERPROC)
XX(#GATHER, GRAPH, GRAPHCALL)
XX(#HELP, HELP, HELPREQUEST)
XX(TRUE, IF, IFPROC)
ZZ("INT", int_X, PF_XX)
XX(TRUE, INTO, NOTAVAILCALL)
ZZ("INV", rinv_X, PF_XX)
ZZ("LOG", log_X, PF_XX)
ZZ("MAX", max_X, TERM_XX)
XX(TRUE, MERGE, NOTAVAILCALL)
ZZ("MIN", min_X, TERM_XX)
ZZ("MOD", mod_X, TERM_XX)
XX(#MOVE, MOVE, MOVEPROC)
XX(#MOVE, MOVEX, AXMOVPROC)
XX(#MOVE, MOVEY, AXMOVPROC)
XX(#MOVE, MOVEZ, AXMOVPROC)
XX(#DISPL, NODISPLAY, NODISPLAYCALL)
XX(#DISPL, NOUPDATE, [$ALLOW←$ALLOW+1])
XX(TRUE, ON, ONPROC)
XX(#MOVE, OPEN, OPCLPROC(TOKEN))
ZZ("OR", oor_X, BEFACT_XX)
XXZZ(TRUE, ORIENT, COORDPROC(0,#RT), ORIENT_X, PF_XX)
XX(#MOVE, PARK, PARKINGPROC)
XXZZ(TRUE, POS, COORDPROC(0,#VT), POS_X, PF_XX)
XX(TRUE, PRINT, PRINTPROC)
XX(TRUE, PROCEDURE, PROCDECLPROC)
XX(TRUE, PROMPT, PROMPTPROC)
XX(TRUE, QBAIL, QBLCALL)
XX(TRUE, QDELETE, DELETECALL(TRUE))
XX(#OUTPT, QREAD, READCALL(FALSE))
XX(#OUTPT, READ, READCALL)
XX(TRUE, READMESSAGE, READMESSCALL)
XX(#WRIST, READWRIST, READWRISTPROC)
XX(TRUE, REDEFINE, REDEFINECALL)
XX(#DISPL, REDISPLAY, REDISPLAYCALL)
XX(TRUE, REFERENCE, NOTAVAILCALL)
ZZ("REL", rel_X, FACTOR_XX)
XX(TRUE, RENAME, EDITCALL("RENAME"))
XX(TRUE, RETURN, RETURNPROC)
! ZZ("ROT", ROT_X, PF_XX) ;
XXZZ(TRUE, ROT, DECLPROC(#RT), ROT_X, PF_XX)
XX(TRUE, SCALAR, DECLPROC(#SC))
XX(TRUE, SETBASE, SETBASEPROC)
XX(TRUE, SETSTATUS, SETSTATUSCALL)
XX(TRUE, SETSTIFF, SETSTIFFPROC)
XX(TRUE, SHOW, SHOWCALL)
ZZ("SIN", sin_X, PF_XX)
ZZ("SQRT", sqrt_X, PF_XX)
XX(TRUE, STOPMESSAGE, STOPMESSCALL)
XX(TRUE, SUBTREE, NOTAVAILCALL)
ZZ("TAN", tan_X, PF_XX)
XX(#MOVE, TO, DEFLT("TO"))
XXZZ(TRUE, TRANS, DECLPROC(#TR), TRANS_X, PF_XX)
XX(TRUE, UNFIX, UNFIXPROC)
ZZ("UNIT", uvect_X, PF_XX)
XX(#DISPL, UPDATE, [$ALLOW←$ALLOW-1])
XX(TRUE, VALUE, NOTAVAILCALL)
XXZZ(TRUE, VECTOR, DECLPROC(#VT), VECTOR_X, PF_XX)
XX(TRUE, VT05_OFF, VT05PROC(1))
XX(TRUE, VT05_ON, VT05PROC(0))
XX(TRUE, WHILE, WHILEPROC)
XX(TRUE, WRIST, WRISTPROC)
XX(#OUTPT, WRITE, WRITCALL)
ZZ("WRT", wrt_X, FACTOR_XX)
XXZZ(TRUE, XCOORD, COORDPROC(1,#SC), COORDX_X, PF_XX)
ZZ("XOR", xxor_X, BEFACT_XX)
XXZZ(TRUE, YCOORD, COORDPROC(2,#SC), COORDY_X, PF_XX)
XXZZ(TRUE, ZCOORD, COORDPROC(3,#SC), COORDZ_X, PF_XX)
ZZ("↑", stos_X, FACTOR_XX)
ZZ("|", MAGNITUDE_X, PF_XX)
];
! tables to set up reserved words ;
! count number of reserved tokens ;
define res_count = 0;
redefine zz(symb,opnum,precedence_level)"[][]"=[redefine res_count=res_count+1;];
redefine xxzz(#flag,str,parsing_proc,opnum,precedence_level)"[][]"
=[redefine res_count=res_count+1;];
redefine xx(#flag, str, parsing_proc)"[][]"=[redefine res_count=res_count+1;];
! **************************************** ;
! *****; tokencodes; ! ******** ;
! at this point res_count contains actual # of reserved words ;
! set up a string array of reserved tokens in RESCODE ;
redefine xx(#flag, str, parsing_proc)"[][]"=["str", ];
redefine xxzz(#flag,str,parsing_proc,opnum,precedence_level)"[][]"=["str",];
redefine zz(symb,opnum,precedence_level)"[][]"=[symb,];
preset_array( rescode , tokencodes , string , 1 , res_count);
! set up an integer array of codes for the reserved tokens ;
define xx_count=0;
redefine xx(#flag, str, parsing_proc)"[][]"=[
redefine xx_count=xx_count+1;
xx_count*(#OPERATORS+1)*#DTYPE, ];
redefine zz(symb,opnum,precedence_level)=
[opnum*#DTYPE+precedence_level,];
redefine xxzz(#flag,str,parsing_proc,opnum,precedence_level)"[][]"=[
redefine xx_count=xx_count+1;
(xx_count*(#OPERATORS+1)+opnum)*#DTYPE+precedence_level, ];
! ***** now set up the array as TCODES ***** ;
preset_array(tcodes, tokencodes, integer, 1, res_count);
! decoding a token to give its various parameters ;
! res_class = class of reserved word, 0 if strict operator
token_class = operator class
token_index = precedence level ;
INTERNAL INTEGER PROCEDURE DECSTR(string VAL);
BEGIN INTEGER L,M,U,I1,I2; STRING S1,S2;
L←1; U←res_count;
DO begin M←(U+L)/2;
CASE COMPEQU(rescode[M],VAL)+1 OF
BEGIN
[-1+1] U←M-1;
[0+1] begin res_class←TCODES[M] DIV( (#OPERATORS+1)*#DTYPE);
tokenclass←tcodeS[m] mod #dtype;
tokenindex← (tcodeS[m] div #dtype) mod (#OPERATORS+1);
RETURN(M);
end;
[1+1] L←M+1
END;
end UNTIL L>U;
res_class←tokenclass←tokenindex←0;
RETURN(0);
END;
! procedure parse itself;
INTERNAL RECURSIVE RPTR(EXPR$)PROCEDURE PARSE;
BEGIN "PARSER"
$$PCODE←NULL_RECORD; ! initialize at beginning of statement;
NOEXPAND←FALSE; ! enable macro expansions ;
GTOKEN; ! reads first token;
STBEGIN←FALSE; ! acknowledge that no longer beginning
of statement;
IF "A"≤ TOKEN ≤"Z" THEN
CASE res_class of
BEGIN "CASE"
redefine xx(#flag, str,oper)"[][]"=[
ifc #flag thenc ; oper elsec ; notavailcall endc];
redefine xxzz(#flag, str,oper,arg1,arg2)"[][]"=[
; oper ];
redefine zz(arg1,arg2,arg3)"[][]"=[];
OTHER
tokencodes
END "CASE"
ELSE IF TOKEN=";" OR TOKEN=NULL THEN
BEGIN IF $COMPILE THEN STOKEN←TRUE END
ELSE IF TOKEN="?" THEN IFC #HELP
THENC HELPREQUEST
ELSEC PRINT(#VERSION) ENDC
ELSE IFC #ARROW THENC
IF TOKEN="↑"
THEN BEGIN $ARROW←$ARROW+20; UPDATE; END
ELSE IF TOKEN="↓"
THEN BEGIN $ARROW←$ARROW-20; UPDATE; END
ELSE IF #TOKEN=INT_TYPE
THEN BEGIN
INTEGER NUM;
NUM←INTSCAN(TOKEN,$BRCHR);
GTOKEN;
IF TOKEN="↓" THEN $ARROW←$ARROW-NUM*20
ELSE IF TOKEN="↑" THEN $ARROW←$ARROW+NUM*20
ELSE ERROR($SYNMSG[32],NULL);
UPDATE;
END
ELSE ENDC
BEGIN $HELP←8; ERROR($SYNMSG[31],NULL); END;
IF NOT $COMPILE
THEN BEGIN "interpret it"
$ALLOW←$ALLOW+1;
IF $$PCODE THEN $EXECUTE($$PCODE);
$$PCODE←NULL_RECORD;
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE; ENDC
END;
RETURN($$PCODE);
END "PARSER";
END "PARSE";